home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / LOCALM~1 / PicTool.bas < prev    next >
BASIC Source File  |  1997-06-14  |  12KB  |  362 lines
  1. Attribute VB_Name = "MPicTool"
  2. Option Explicit
  3.  
  4. Private Declare Sub OleCreatePictureIndirect Lib "olepro32.dll" ( _
  5.     lpPictDesc As PICTDESC, riid As IID, _
  6.     ByVal fPictureOwnsHandle As Long, ipic As IPicture)
  7.  
  8. Private dxyShell As Long
  9.  
  10. Public Enum EErrorPicTool
  11.     eeBasePicTool = 13560   ' PicTool
  12. End Enum
  13.  
  14. Public Enum EIconSize
  15.     eisDefault = -1
  16.     eisImage = -2
  17.     eisSmall = -3
  18.     eisHuge = -4
  19.     eisShell = -5
  20. End Enum
  21.  
  22. Public Enum EConversions
  23.     TwipsPerPoint = 20
  24.     TwipsPerCharX = 120
  25.     TwipsPerCharY = 240
  26.     TwipsPerInch = 1440
  27.     TwipsPerDecimeter = 5669
  28. End Enum
  29.  
  30. '' Scale conversion procedures
  31.  
  32. #If fComponent Then
  33. ' Public for global class
  34. Function TwipsPerCentimeter() As Single
  35.     TwipsPerCentimeter = 566.9
  36. End Function
  37.  
  38. Function TwipsPerMillimeter() As Single
  39.     TwipsPerMillimeter = 56.69
  40. End Function
  41.  
  42. Function TwipsPerHiMetricUnit() As Single
  43.     TwipsPerHiMetricUnit = 0.5669
  44. End Function
  45. #Else
  46. ' Public for standard module (incorrectly marked as error in global class)
  47. Public Const TwipsPerCentimeter = 566.9
  48. Public Const TwipsPerMillimeter = 56.69
  49. Public Const TwipsPerHiMetricUnit = 0.5669
  50. #End If
  51.  
  52. Function PicXToPixel(ByVal xHiMetric As Long) As Long
  53.     PicXToPixel = xHiMetric * TwipsPerDecimeter / Screen.TwipsPerPixelX / 10000
  54. End Function
  55.  
  56. Function PicYToPixel(ByVal yHiMetric As Long) As Long
  57.     PicYToPixel = yHiMetric * TwipsPerDecimeter / Screen.TwipsPerPixelY / 10000
  58. End Function
  59.  
  60. '' Picture conversion procedures
  61.  
  62. Function IconToPicture(ByVal hIcon As Long) As IPicture
  63.     If hIcon = hNull Then Exit Function
  64.     Dim ipic As IPicture, picdes As PICTDESC, iidIPicture As IID
  65.     ' Fill picture description
  66.     picdes.cbSizeofstruct = Len(picdes)
  67.     picdes.picType = vbPicTypeIcon
  68.     picdes.hgdiobj = hIcon
  69.     ' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
  70.     iidIPicture.Data1 = &H7BF80980
  71.     iidIPicture.Data2 = &HBF32
  72.     iidIPicture.Data3 = &H101A
  73.     iidIPicture.Data4(0) = &H8B
  74.     iidIPicture.Data4(1) = &HBB
  75.     iidIPicture.Data4(2) = &H0
  76.     iidIPicture.Data4(3) = &HAA
  77.     iidIPicture.Data4(4) = &H0
  78.     iidIPicture.Data4(5) = &H30
  79.     iidIPicture.Data4(6) = &HC
  80.     iidIPicture.Data4(7) = &HAB
  81.     ' Create picture from icon handle
  82.     OleCreatePictureIndirect picdes, iidIPicture, True, ipic
  83.     ' Result will be valid Picture or Nothing--either way set it
  84.     Set IconToPicture = ipic
  85. End Function
  86.  
  87. Function CursorToPicture(ByVal hIcon As Long) As IPicture
  88.     ' It's just an alias
  89.     Set CursorToPicture = IconToPicture(hIcon)
  90. End Function
  91.  
  92. Function BitmapToPicture(ByVal hBmp As Long, _
  93.                          Optional ByVal hPal As Long = hNull) _
  94.                          As IPicture
  95.     ' Fill picture description
  96.     Dim ipic As IPicture, picdes As PICTDESC, iidIPicture As IID
  97.     picdes.cbSizeofstruct = Len(picdes)
  98.     picdes.picType = vbPicTypeBitmap
  99.     picdes.hgdiobj = hBmp
  100.     picdes.hPalOrXYExt = hPal
  101.     ' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
  102.     iidIPicture.Data1 = &H7BF80980
  103.     iidIPicture.Data2 = &HBF32
  104.     iidIPicture.Data3 = &H101A
  105.     iidIPicture.Data4(0) = &H8B
  106.     iidIPicture.Data4(1) = &HBB
  107.     iidIPicture.Data4(2) = &H0
  108.     iidIPicture.Data4(3) = &HAA
  109.     iidIPicture.Data4(4) = &H0
  110.     iidIPicture.Data4(5) = &H30
  111.     iidIPicture.Data4(6) = &HC
  112.     iidIPicture.Data4(7) = &HAB
  113.     ' Create picture from bitmap handle
  114.     OleCreatePictureIndirect picdes, iidIPicture, True, ipic
  115.     ' Result will be valid Picture or Nothing--either way set it
  116.     Set BitmapToPicture = ipic
  117. End Function
  118.  
  119. Function MetafileToPicture(ByVal hMeta As Long, _
  120.                            ByVal xExt As Integer, _
  121.                            ByVal yExt As Integer, _
  122.                            Optional fOld As Boolean) As IPicture
  123.     If hMeta = hNull Then Exit Function
  124.     Dim ipic As IPicture, picdes As PICTDESC, iidIPicture As IID
  125.     ' Fill picture description (assume enhanced)
  126.     picdes.cbSizeofstruct = Len(picdes)
  127.     If fOld Then
  128.         picdes.picType = vbPicTypeMetafile
  129.     Else
  130.         picdes.picType = vbPicTypeEMetafile
  131.     End If
  132.     picdes.hgdiobj = hMeta
  133.     picdes.hPalOrXYExt = MBytes.MakeDWord(xExt, yExt) ' Fake union
  134.     ' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
  135.     iidIPicture.Data1 = &H7BF80980
  136.     iidIPicture.Data2 = &HBF32
  137.     iidIPicture.Data3 = &H101A
  138.     iidIPicture.Data4(0) = &H8B
  139.     iidIPicture.Data4(1) = &HBB
  140.     iidIPicture.Data4(2) = &H0
  141.     iidIPicture.Data4(3) = &HAA
  142.     iidIPicture.Data4(4) = &H0
  143.     iidIPicture.Data4(5) = &H30
  144.     iidIPicture.Data4(6) = &HC
  145.     iidIPicture.Data4(7) = &HAB
  146.     ' Create picture from icon handle
  147.     OleCreatePictureIndirect picdes, iidIPicture, True, ipic
  148.     ' Result will be valid Picture or Nothing--either way set it
  149.     Set MetafileToPicture = ipic
  150. End Function
  151.  
  152. ' Create a mask on destination DC from source DC of specified size
  153. Function MakeMask(picSrc As StdPicture) As StdPicture
  154.     Dim hdcSrc As Long, hbmpSrc As Long
  155.     Dim hdcDst As Long, hbmpDst As Long
  156.     Dim dxSrc As Long, dySrc As Long
  157.     
  158.     ' Get picture size
  159.     dxSrc = PicXToPixel(picSrc.Width)
  160.     dySrc = PicYToPixel(picSrc.Height)
  161.     
  162.     ' Select source into memory DC
  163.     
  164.     
  165.     ' Create memory device context for destination
  166.     hdcDst = CreateCompatibleDC(0)
  167.     ' Create monochrome bitmap and select it into DC
  168.     hbmpDst = CreateCompatibleBitmap(hdcDst, dxSrc, dySrc)
  169.     hbmpDst = SelectObject(hdcDst, hbmpDst)
  170.     ' Copy color bitmap to DC to create mono mask
  171.     BitBlt hdcDst, 0, 0, dxSrc, dySrc, hdcSrc, 0, 0, SRCCOPY
  172.     ' Clean up
  173.     Call SelectObject(hdcDst, hbmpDst)
  174.     Call DeleteObject(hbmpDst)
  175.     Call DeleteDC(hdcDst)
  176.     
  177.     'Set MakeMask = BitmapToPicture(hbmpDst)
  178. End Function
  179.  
  180. '' Handle information procedures
  181.  
  182. Sub GetIconSize(ByVal hIcon As Long, dx As Long, dy As Long, _
  183.                 Optional xHot As Long, Optional yHot As Long)
  184.     Dim ico As ICONINFO, bmp As BITMAP, dc As Long, f As Boolean
  185.     f = GetIconInfo(hIcon, ico)
  186.     f = GetObjectBitmap(ico.hbmColor, LenB(bmp), bmp)
  187.     dx = bmp.bmWidth
  188.     dy = bmp.bmHeight
  189.     xHot = ico.xHotspot
  190.     yHot = ico.yHotspot
  191. End Sub
  192.  
  193. Sub GetBitmapSize(ByVal hBitmap As Long, dx As Long, dy As Long)
  194.     Dim bmp As BITMAP, f As Boolean
  195.     f = GetObjectBitmap(hBitmap, LenB(bmp), bmp)
  196.     dx = bmp.bmWidth
  197.     dy = bmp.bmHeight
  198. End Sub
  199.  
  200. Function GetShellIconSize() As Long
  201. #If 1 Then
  202.     ' Grabbing size out of registry works, but might change
  203.     Const sMetrics = "Control Panel\Desktop\WindowMetrics"
  204.     GetShellIconSize = MRegTool.GetRegStr(sMetrics, "Shell Icon Size")
  205. #Else
  206.     ' Recommended way of getting size doesn't work until after login
  207.     Dim hImlst As Long, fi As SHFILEINFO, cx As Long, cy As Long
  208.     hImlst = SHGetFileInfo(".", 0, fi, Len(fi), _
  209.                            SHGFI_SYSICONINDEX Or SHGFI_SHELLICONSIZE)
  210.     If ImageList_GetIconSize(hImlst, cx, cy) Then
  211.         GetShellIconSize = cx
  212.     Else
  213.         GetShellIconSize = -1
  214.     End If
  215. #End If
  216. End Function
  217.  
  218. '' Resource helpers
  219.  
  220. Function ResourceIdToStr(ByVal ID As Long) As String
  221.     Select Case ID
  222.     Case RT_CURSOR
  223.         ResourceIdToStr = "CURSOR"
  224.     Case RT_BITMAP
  225.         ResourceIdToStr = "BITMAP"
  226.     Case RT_ICON
  227.         ResourceIdToStr = "ICON"
  228.     Case RT_MENU
  229.         ResourceIdToStr = "MENU"
  230.     Case RT_DIALOG
  231.         ResourceIdToStr = "DIALOG"
  232.     Case RT_STRING
  233.         ResourceIdToStr = "STRING"
  234.     Case RT_FONTDIR
  235.         ResourceIdToStr = "FONTDIR"
  236.     Case RT_FONT
  237.         ResourceIdToStr = "FONT"
  238.     Case RT_ACCELERATOR
  239.         ResourceIdToStr = "ACCELERATOR"
  240.     Case RT_RCDATA
  241.         ResourceIdToStr = "RCDATA"
  242.     Case RT_MESSAGETABLE
  243.         ResourceIdToStr = "MESSAGETABLE"
  244.     Case RT_GROUP_CURSOR
  245.         ResourceIdToStr = "GROUP_CURSOR"
  246.     Case RT_GROUP_ICON
  247.         ResourceIdToStr = "GROUP_ICON"
  248.     Case RT_VERSION
  249.         ResourceIdToStr = "VERSION"
  250.     Case RT_DLGINCLUDE
  251.         ResourceIdToStr = "DLGINCLUDE"
  252.     Case RT_PLUGPLAY
  253.         ResourceIdToStr = "PLUGPLAY"
  254.     Case RT_VXD
  255.         ResourceIdToStr = "VXD"
  256.     Case Else
  257.         ResourceIdToStr = "Unknown"
  258.     End Select
  259. End Function
  260.  
  261. ' The Win32 UnlockResource function is a macro returning zero. Since you
  262. ' can't emulate this in a type library, this do-nothing function is
  263. ' provided here. Better yet, don't try to unlock resources.
  264. Function UnlockResource(ByVal hResData As Long) As Long
  265.     UnlockResource = 0
  266. End Function
  267.  
  268. Function LoadAnyPicture(Optional sPicture As String, _
  269.                         Optional eis As EIconSize = eisDefault _
  270.                         ) As Picture
  271.     Dim hIcon As Long, sExt As String, xy As Long, af As Long
  272.     ' If no picture, return Nothing (clears picture)
  273.     If sPicture = sEmpty Then Exit Function
  274.     ' Use default LoadPicture for all except icons with argument
  275.     sExt = MUtility.GetFileExt(sPicture)
  276.     If UCase$(sExt) <> ".ICO" Or eis = -1 Then
  277.         Set LoadAnyPicture = VB.LoadPicture(sPicture)
  278.         Exit Function
  279.     End If
  280.     
  281.     Select Case eis
  282.     Case eisSmall
  283.         xy = 16: af = LR_LOADFROMFILE
  284.     Case eisHuge
  285.         xy = 48: af = LR_LOADFROMFILE
  286.     Case eisImage
  287.         xy = 0: af = LR_LOADFROMFILE
  288.     Case eisShell ' Get icon size from system
  289.         xy = GetShellIconSize(): af = LR_LOADFROMFILE
  290.     Case Is > 0   ' Use arbitrary specified size--72 by 72 or whatever
  291.         xy = eis: af = LR_LOADFROMFILE
  292.     Case Else     ' Includes eisDefault
  293.         xy = 0: af = LR_LOADFROMFILE Or LR_DEFAULTSIZE
  294.     End Select
  295.     hIcon = LoadImage(0&, sPicture, IMAGE_ICON, xy, xy, af)
  296.     ' If this fails, use original load
  297.     If hIcon <> hNull Then
  298.         Set LoadAnyPicture = IconToPicture(hIcon)
  299.     Else
  300.         Set LoadAnyPicture = VB.LoadPicture(sPicture)
  301.     End If
  302. End Function
  303.  
  304. Function LoadAnyResPicture(vRes As Variant, iResType As Integer, _
  305.                            Optional eis As EIconSize = eisDefault _
  306.                            ) As Picture
  307.     Dim hIcon As Long, sExt As String, xy As Long, af As Long
  308.     ' Can't use LoadImage in environment--have to make do with default
  309.     If Not MUtility.IsExe() Then
  310.         If (eis = -1) Or (iResType <> vbResIcon) Then
  311.             Set LoadAnyResPicture = VB.LoadResPicture(vRes, iResType)
  312.             Exit Function
  313.         End If
  314.     End If
  315.     
  316.     Select Case eis
  317.     Case eisSmall
  318.         xy = 16: af = LR_LOADFROMFILE
  319.     Case eisHuge
  320.         xy = 48: af = LR_LOADFROMFILE
  321.     Case eisImage
  322.         xy = 0: af = LR_LOADFROMFILE
  323.     Case eisShell   ' Get icon size from system
  324.         xy = GetShellIconSize(): af = LR_LOADFROMFILE
  325.     Case Is > 0     ' Use arbitrary specified size--72 by 72 or whatever
  326.         xy = eis: af = LR_LOADFROMFILE
  327.     Case Else       ' Includes eisDefault
  328.         xy = 0: af = LR_LOADFROMFILE Or LR_DEFAULTSIZE
  329.     End Select
  330.     If TypeName(vRes) = "String" Then
  331.         hIcon = LoadImage(App.hInstance, CStr(vRes), IMAGE_ICON, xy, xy, af)
  332.     Else
  333.         hIcon = LoadImage(App.hInstance, CLng(vRes), IMAGE_ICON, xy, xy, af)
  334.     End If
  335.     If hIcon <> hNull Then
  336.         Set LoadAnyResPicture = IconToPicture(hIcon)
  337.     Else
  338.         Set LoadAnyResPicture = VB.LoadResPicture(vRes, iResType)
  339.     End If
  340. End Function
  341.  
  342. #If fComponent = 0 Then
  343. Private Sub ErrRaise(e As Long)
  344.     Dim sText As String, sSource As String
  345.     If e > 1000 Then
  346.         sSource = App.ExeName & ".PicTool"
  347.         Select Case e
  348.         Case eeBasePicTool
  349.             BugAssert True
  350.        ' Case ee...
  351.        '     Add additional errors
  352.         End Select
  353.         Err.Raise COMError(e), sSource, sText
  354.     Else
  355.         ' Raise standard Visual Basic error
  356.         sSource = App.ExeName & ".VBError"
  357.         Err.Raise e, sSource
  358.     End If
  359. End Sub
  360. #End If
  361.  
  362.